home *** CD-ROM | disk | FTP | other *** search
/ CD ROM Paradise Collection 4 / CD ROM Paradise Collection 4 1995 Nov.iso / program / swagg_m.zip / MATH.SWG / 0059_Text Formula Parser.pas < prev    next >
Pascal/Delphi Source File  |  1994-01-27  |  36KB  |  1,291 lines
  1. {
  2. │ I've written a pwoerfull formula evaluator which can be extended
  3. │ during run-time by adding fuctions, vars and strings containing
  4. │ Because its not very small post me a message if you want to receive it.
  5.  
  6. Here it goes. It's a unit and an example/demo of some features.
  7.  
  8. {---------------------------------------------------------}
  9. {  Project : Text Formula Parser                          }
  10. {  Auteur  : G.W. van der Vegt                            }
  11. {---------------------------------------------------------}
  12. {  Datum .tijd  Revisie                                   }
  13. {  900530.1900  Creatie (function call/exits removed)     }
  14. {  900531.1900  Revisie (Boolean expressions)             }
  15. {  900104.2100  Revisie (HEAP Function Storage)           }
  16. {  910327.1345  External Real string vars (tfp_realstr)   }
  17. {               are corrected the same way as the parser  }
  18. {               corrects them before using TURBO's VAL    }
  19. {---------------------------------------------------------}
  20.  
  21. UNIT Tfp_01;
  22.  
  23. INTERFACE
  24.  
  25. {---------------------------------------------------------}
  26. {----Initializes function database                        }
  27. {---------------------------------------------------------}
  28.  
  29. PROCEDURE Tfp_init(no : INTEGER);
  30.  
  31. {---------------------------------------------------------}
  32. {----Parses s and returns REAL or STR(REAL:m:n)           }
  33. {---------------------------------------------------------}
  34.  
  35. FUNCTION  Tfp_parse2real(s : STRING) : REAL;
  36.  
  37. FUNCTION  Tfp_parse2str(s : STRING;m,n : INTEGER) : STRING;
  38.  
  39. {---------------------------------------------------------}
  40. {----Tfp_errormsg(tfp_ernr) returns errormessage          }
  41. {---------------------------------------------------------}
  42.  
  43. VAR
  44.   Tfp_ernr  : BYTE;                     {----Errorcode}
  45.  
  46. FUNCTION  Tfp_errormsg(nr : INTEGER) : STRING;
  47.  
  48.  
  49. {---------------------------------------------------------}
  50. {----Internal structure for functions/vars                }
  51. {---------------------------------------------------------}
  52.  
  53. TYPE
  54.   tfp_fname = STRING[12];               {----String name                     }
  55.  
  56.   tfp_ftype = (tfp_noparm,              {----Function or Function()          }
  57.                tfp_1real,               {----Function(VAR r)                 }
  58.                tfp_2real,               {----Function(VAR r1,r2)             }
  59.                tfp_nreal,               {----Function(VAR r;n  INTEGER)      }
  60.                tfp_realvar,             {----Real VAR                        }
  61.                tfp_intvar,              {----Integer VAR                     }
  62.                tfp_boolvar,             {----Boolean VAR                     }
  63.                tfp_realstr);            {----Real String VAR                 }
  64.  
  65. CONST
  66.   tfp_true  = 1.0;                      {----REAL value for BOOLEAN TRUE     }
  67.   tfp_false = 0.0;                      {----REAL value for BOOLEAN FALSE    }
  68.  
  69. {---------------------------------------------------------}
  70. {----Adds own FUNCTION or VAR to the parser               }
  71. {    All FUNCTIONS & VARS must be compiled                }
  72. {    with the FAR switch on                               }
  73. {---------------------------------------------------------}
  74.  
  75. PROCEDURE Tfp_addobj(a : pointer;n : tfp_fname;t : tfp_ftype);
  76.  
  77.  
  78. {---------------------------------------------------------}
  79. {----Add Internal Function Packs                          }
  80. {---------------------------------------------------------}
  81.  
  82. PROCEDURE Tfp_addgonio;
  83.  
  84. PROCEDURE Tfp_addlogic;
  85.  
  86. PROCEDURE Tfp_addmath;
  87.  
  88. PROCEDURE Tfp_addmisc;
  89.  
  90. {---------------------------------------------------------}
  91.  
  92. IMPLEMENTATION
  93.  
  94. CONST
  95.   maxreal  = +9.99999999e37;            {----Internal maxreal                }
  96.   maxparm  = 16;                        {----Maximum number of parameters    }
  97.  
  98. VAR
  99.   maxfie   : INTEGER;                   {----max no of functions & vars      }
  100.   fiesiz   : INTEGER;                   {----current no of functions & vars  }
  101.  
  102. TYPE
  103.   fie      = RECORD
  104.                fname : tfp_fname;       {----Name of function or var         }
  105.                faddr : POINTER;         {----FAR POINTER to function or var  }
  106.                ftype : tfp_ftype;       {----Type of entry                   }
  107.              END;
  108.  
  109.   fieptr   = ARRAY[1..1] OF fie;        {----Will be used as [1..maxfie]     }
  110.  
  111. VAR
  112.   fiearr   : ^fieptr;                   {----Array of functions & vars       }
  113.  
  114. {---------------------------------------------------------}
  115.  
  116. VAR
  117.   Line     : STRING;                    {----Internal copy of string to Parse}
  118.   Lp       : INTEGER;                   {----Parsing Pointer into Line       }
  119.   Nextchar : CHAR;                      {----Character at Lp Postion         }
  120.  
  121. {---------------------------------------------------------}
  122. {----Tricky stuff to call FUNCTIONS                       }
  123. {---------------------------------------------------------}
  124.  
  125. {$F+}
  126.  
  127. VAR
  128.   GluePtr : POINTER;
  129.  
  130. FUNCTION Call_noparm : REAL;
  131.  
  132.  INLINE($FF/$1E/GluePtr);  {CALL DWORD PTR GluePtr}
  133.  
  134. FUNCTION Call_1real(VAR r) : REAL;
  135.  
  136.  INLINE($FF/$1E/GluePtr);  {CALL DWORD PTR GluePtr}
  137.  
  138. FUNCTION Call_2real(VAR r1,r2) : REAL;
  139.  
  140.  INLINE($FF/$1E/GluePtr);  {CALL DWORD PTR GluePtr}
  141.  
  142. FUNCTION Call_nreal(VAR r,n) : REAL;
  143.  INLINE($FF/$1E/GluePtr);  {CALL DWORD PTR GluePtr}
  144.  
  145. {$F-}
  146.  
  147. {---------------------------------------------------------}
  148. {----This routine skips one character                     }
  149. {---------------------------------------------------------}
  150.  
  151. PROCEDURE Newchar;
  152.  
  153. BEGIN
  154.   IF (lp<LENGTH(Line))
  155.     THEN INC(Lp);
  156.   Nextchar:=UPCASE(Line[Lp]);
  157. END;
  158.  
  159. {---------------------------------------------------------}
  160. {----This routine skips one character and                 }
  161. {    all folowing spaces from an expression               }
  162. {---------------------------------------------------------}
  163.  
  164. PROCEDURE Skip;
  165.  
  166. BEGIN
  167.   REPEAT
  168.     Newchar;
  169.   UNTIL (Nextchar<>' ');
  170. END;
  171.  
  172. {---------------------------------------------------------}
  173. {  Number     = Real    (Bv 23.4E-5)                      }
  174. {               Integer (Bv -45)                          }
  175. {---------------------------------------------------------}
  176.  
  177. FUNCTION Eval_number : REAL;
  178.  
  179. VAR
  180.   Temp  : STRING;
  181.   Err   : INTEGER;
  182.   value : REAL;
  183.  
  184. BEGIN
  185. {----Correct .xx to 0.xx}
  186.   IF (Nextchar='.')
  187.     THEN Temp:='0'+Nextchar
  188.     ELSE Temp:=Nextchar;
  189.  
  190.   Newchar;
  191.  
  192. {----Correct ±.xx to ±0.xx}
  193.   IF (LENGTH(temp)=1) AND (Temp[1] IN ['+','-']) AND (Nextchar='.')
  194.     THEN Temp:=Temp+'0';
  195.  
  196.   WHILE Nextchar IN ['0'..'9','.','E'] DO
  197.     BEGIN
  198.       Temp:=Temp+Nextchar;
  199.       IF (Nextchar='E')
  200.         THEN
  201.           BEGIN
  202.           {----Correct ±xxx.E to ±xxx.0E}
  203.             IF (Temp[LENGTH(Temp)-1]='.')
  204.               THEN INSERT('0',Temp,LENGTH(Temp));
  205.             Newchar;
  206.             IF (Nextchar IN ['+','-'])
  207.               THEN
  208.                 BEGIN
  209.                   Temp:=Temp+Nextchar;
  210.                   Newchar;
  211.                 END;
  212.           END
  213.         ELSE Newchar;
  214.     END;
  215.  
  216. {----Skip trailing spaces}
  217.   IF (line[lp]=' ')
  218.     THEN WHILE (Line[lp]=' ') DO INC(lp);
  219.   nextchar:=line[lp];
  220.  
  221. {----Correct ±xx. to ±xx.0 but NOT ±xxE±yy.}
  222.   IF (temp[LENGTH(temp)]='.') AND
  223.      (POS('E',temp)=0)
  224.     THEN Temp:=Temp+'0';
  225.  
  226.   VAL(Temp,value,Err);
  227.  
  228.   IF (Err<>0) THEN tfp_ernr:=1;
  229.  
  230.   IF (tfp_ernr=0)
  231.     THEN Eval_number:=value
  232.     ELSE Eval_number:=0;
  233. END;
  234.  
  235. {---------------------------------------------------------}
  236.  
  237. FUNCTION Eval_b_expr : REAL; FORWARD;
  238.  
  239. {---------------------------------------------------------}
  240. {  Factor     = Number                                    }
  241. {    (External) Function()                                }
  242. {    (External) Function(Expr)                            }
  243. {    (External) Function(Expr,Expr)                       }
  244. {     External  Var Real                                  }
  245. {     External  Var Integer                               }
  246. {     External  Var Boolean                               }
  247. {     External  Var realstring                            }
  248. {               (R_Expr)                                  }
  249. {---------------------------------------------------------}
  250.  
  251. FUNCTION Eval_factor : REAL;
  252.  
  253. VAR
  254.   ferr    : BOOLEAN;
  255.   param   : INTEGER;
  256.   dummy   : ARRAY[0..maxparm] OF REAL;
  257.   value,
  258.   dummy1,
  259.   dummy2  : REAL;
  260.   temp    : tfp_fname;
  261.   e,
  262.   i,
  263.   index   : INTEGER;
  264.   temps   : STRING;
  265.  
  266. BEGIN
  267.   CASE Nextchar OF
  268.     '+'  : BEGIN
  269.              Newchar;
  270.              value:=+Eval_factor;
  271.            END;
  272.     '-'  : BEGIN
  273.              Newchar;
  274.              value:=-Eval_factor;
  275.            END;
  276.  
  277.     '0'..'9',
  278.     '.'  : value:=Eval_number;
  279.     'A'..'Z'
  280.          : BEGIN
  281.              ferr:=TRUE;
  282.              Temp:=Nextchar;
  283.              Skip;
  284.              WHILE Nextchar IN ['0'..'9','_','A'..'Z'] DO
  285.                BEGIN
  286.                  Temp:=Temp+Nextchar;
  287.                  Skip;
  288.                END;
  289.  
  290.            {----Seek function and CALL it}
  291.              {$R-}
  292.              FOR Index:=1 TO Fiesiz DO
  293.                WITH fiearr^[index] DO
  294.                  IF (fname=temp)
  295.                    THEN
  296.                      BEGIN
  297.                        ferr:=FALSE;
  298.  
  299.                        CASE ftype OF
  300.  
  301.                        {----Function or Function()}
  302.                          tfp_noparm  : IF (nextchar='(')
  303.                                         THEN
  304.                                           BEGIN
  305.                                             Skip;
  306.  
  307.                                             IF (nextchar<>')')
  308.                                               THEN tfp_ernr:=15;
  309.  
  310.                                             Skip;
  311.                                           END;
  312.  
  313.                        {----Function(r)}
  314.                          tfp_1real   : IF (nextchar='(')
  315.                                          THEN
  316.                                            BEGIN
  317.                                              Skip;
  318.  
  319.                                              dummy1:=Eval_b_expr;
  320.  
  321.                                              IF (tfp_ernr=0) AND
  322.                                                 (nextchar<>')')
  323.                                                THEN tfp_ernr:=15;
  324.  
  325.                                              Skip; {----Dump the ')'}
  326.                                            END
  327.                                          ELSE tfp_ernr:=15;
  328.  
  329.                        {----Function(r1,r2)}
  330.                          tfp_2real   : IF (nextchar='(')
  331.                                          THEN
  332.                                            BEGIN
  333.                                              Skip;
  334.  
  335.                                              dummy1:=Eval_b_expr;
  336.  
  337.                                              IF (tfp_ernr=0) AND
  338.                                                 (nextchar<>',')
  339.                                                THEN tfp_ernr:=15;
  340.  
  341.                                              Skip; {----Dump the ','}
  342.                                              dummy2:=Eval_b_expr;
  343.  
  344.                                               IF (tfp_ernr=0) AND
  345.                                                  (nextchar<>')')
  346.                                                 THEN tfp_ernr:=15;
  347.  
  348.                                               Skip; {----Dump the ')'}
  349.                                             END
  350.                                           ELSE tfp_ernr:=15;
  351.  
  352.                        {----Function(r,n)}
  353.                          tfp_nreal   : IF (nextchar='(')
  354.                                          THEN
  355.                                            BEGIN
  356.                                              param:=0;
  357.  
  358.                                              Skip;
  359.                                              dummy[param]:=Eval_b_expr;
  360.  
  361.                                              IF (tfp_ernr=0) AND
  362.                                                 (nextchar<>',')
  363.                                                THEN tfp_ernr:=15
  364.                                                ELSE
  365.                                                  WHILE (tfp_ernr=0) AND
  366.                                                        (nextchar=',') AND
  367.                                                        (param<maxparm) DO
  368.                                                    BEGIN
  369.                                                      Skip; {----Dump the ','}
  370.                                                      INC(param);
  371.                                                      dummy[param]:=Eval_b_expr;
  372.                                                    END;
  373.  
  374.                                              IF (tfp_ernr=0) AND
  375.                                                 (nextchar<>')')
  376.                                                THEN tfp_ernr:=15;
  377.  
  378.                                              Skip; {----Dump the ')'}
  379.                                            END
  380.                                          ELSE tfp_ernr:=15;
  381.                        {----Real Var}
  382.                          tfp_realvar    : dummy1:=REAL(faddr^);
  383.  
  384.                        {----Integer Var}
  385.                          tfp_intvar     : dummy1:=1.0*INTEGER(faddr^);
  386.  
  387.                        {----Boolean Var}
  388.                          tfp_boolvar    : dummy1:=1.0*ORD(BOOLEAN(faddr^));
  389.  
  390.                        {----Real string Var}
  391.                          tfp_realstr    : BEGIN
  392.                                              temps:=STRING(faddr^);
  393.  
  394.                                            {----Delete Leading Spaces}
  395.                                              WHILE (Length(temps)>0) AND
  396.                                                    (temps[1]=' ') DO
  397.                                                Delete(temps,1,1);
  398.  
  399.                                            {----Delete Trailing Spaces}
  400.                                              WHILE (Length(temps)>0) AND
  401.                                                    (temps[Length(temps)]=' ') Do
  402.                                                Delete(temps,Length(temps),1);
  403.  
  404.                                           {----Correct .xx to 0.xx}
  405.                                              IF (LENGTH(temps)>=1)  AND
  406.                                                 (LENGTH(temps)<255) AND
  407.                                                 (temps[1]='.')
  408.                                                THEN Insert('0',temps,1);
  409.  
  410.                                            {----Correct ±.xx to ±0.xx}
  411.                                              IF (LENGTH(temps)>=2) AND
  412.                                                 (LENGTH(temps)<255) AND
  413.                                                 (temps[1] IN ['+','-']) AND
  414.                                                 (temps[2]='.')
  415.                                                THEN Insert('0',temps,2);
  416.  
  417.                                            {----Correct xx.Eyy to xx0.Exx}
  418.                                              IF (Pos('.E',temps)>0) AND
  419.                                                 (Length(temps)<255)
  420.                                                THEN Insert('0',temps,Pos('.E',temps));
  421.  
  422.                                            {----Correct xx.eyy to xx0.exx}
  423.                                              IF (Pos('.e',temps)>0) AND
  424.                                                 (Length(temps)<255)
  425.                                                THEN Insert('0',temps,Pos('.e',temps));
  426.                                            {----Correct ±xx. to ±xx.0 but NOT ±}
  427.                                              IF (temps[LENGTH(temps)]='.') AND
  428.                                                 (POS('E',temps)=0) AND
  429.                                                 (POS('e',temps)=0) AND
  430.                                                 (Length(temps)<255)
  431.                                                THEN Temps:=Temps+'0';
  432.  
  433.                                              VAL(temps,dummy1,e);
  434.                                              IF (e<>0)
  435.                                                THEN tfp_ernr:=1;
  436.                                            END;
  437.                        END;
  438.  
  439.                        IF (tfp_ernr=0)
  440.                          THEN
  441.                            BEGIN
  442.                              glueptr:=faddr;
  443.  
  444.                              CASE ftype OF
  445.                                tfp_noparm   : value:=call_noparm;
  446.                                tfp_1real    : value:=call_1real(dummy1);
  447.                                tfp_2real    : value:=call_2real(dummy1,dummy2);
  448.                                tfp_nreal    : value:=call_nreal(dummy,param);
  449.                                tfp_realvar,
  450.                                tfp_intvar,
  451.                                tfp_boolvar,
  452.                                tfp_realstr  : value:=dummy1;
  453.                              END;
  454.                            END;
  455.                      END;
  456.              IF (ferr=TRUE)
  457.                THEN tfp_ernr:=2;
  458.  
  459.              {$R+}
  460.            END;
  461.  
  462.     '('  : BEGIN
  463.              Skip;
  464.  
  465.              value:=Eval_b_expr;
  466.  
  467.              IF (tfp_ernr=0) AND (nextchar<>')') THEN tfp_ernr:=3;
  468.  
  469.              Skip; {----Dump the ')'}
  470.            END;
  471.  
  472.     ELSE tfp_ernr:=2;
  473.   END;
  474.  
  475.   IF (tfp_ernr=0)
  476.     THEN Eval_factor:=value
  477.     ELSE Eval_factor:=0;
  478.  
  479. END;
  480.  
  481. {---------------------------------------------------------}
  482. {  Term       = Factor ^ Factor                           }
  483. {---------------------------------------------------------}
  484.  
  485. FUNCTION Eval_term : REAL;
  486.  
  487. VAR
  488.   value,
  489.   Exponent,
  490.   dummy,
  491.   Base      : REAL;
  492.  
  493. BEGIN
  494.   value:=Eval_factor;
  495.  
  496.   WHILE (tfp_ernr=0) AND (Nextchar='^') DO
  497.     BEGIN
  498.       Skip;
  499.  
  500.       Exponent:=Eval_factor;
  501.  
  502.       Base:=value;
  503.       IF (tfp_ernr=0) AND (Base=0)
  504.         THEN value:=0
  505.         ELSE
  506.           BEGIN
  507.  
  508.           {----Over/Underflow Protected}
  509.             dummy:=Exponent*LN(ABS(Base));
  510.             IF (dummy<=LN(MAXREAL))
  511.                THEN value:=EXP(dummy)
  512.                ELSE tfp_ernr:=11;
  513.           END;
  514.  
  515.       IF (tfp_ernr=0) AND (Base<0)
  516.         THEN
  517.           BEGIN
  518.           {----allow only whole number exponents}
  519.             IF (INT(Exponent)<>Exponent) THEN tfp_ernr:=4;
  520.  
  521.             IF (tfp_ernr=0) AND ODD(ROUND(exponent)) THEN value:=-value;
  522.           END;
  523.     END;
  524.  
  525.   IF (tfp_ernr=0)
  526.     THEN Eval_term:=value
  527.     ELSE Eval_term:=0;
  528. END;
  529.  
  530. {---------------------------------------------------------}
  531. {----Subterm  = Term * Term                               }
  532. {               Term / Term                               }
  533. {---------------------------------------------------------}
  534.  
  535. FUNCTION Eval_subterm : REAL;
  536.  
  537. VAR
  538.   value,
  539.   dummy  : REAL;
  540.  
  541. BEGIN
  542.   value:=Eval_term;
  543.  
  544.   WHILE (tfp_ernr=0) AND (Nextchar IN ['*','/']) DO
  545.     CASE Nextchar OF
  546.  
  547.     {----Over/Underflow Protected}
  548.       '*' : BEGIN
  549.               Skip;
  550.  
  551.               dummy:=Eval_term;
  552.  
  553.               IF (tfp_ernr<>0) OR (value=0) OR (dummy=0)
  554.                 THEN value:=0
  555.                 ELSE IF (ABS( LN(ABS(value)) + LN(ABS(dummy)) )<LN(Maxreal))
  556.                   THEN value:= value * dummy
  557.                   ELSE tfp_ernr:=11;
  558.             END;
  559.  
  560.     {----Over/Underflow Protected}
  561.       '/' : BEGIN
  562.               Skip;
  563.  
  564.               dummy:=Eval_term;
  565.  
  566.               IF (tfp_ernr=0)
  567.                 THEN
  568.                   BEGIN
  569.  
  570.                   {----Division by ZERO Protected}
  571.                     IF (dummy<>0)
  572.                       THEN
  573.                         BEGIN
  574.                         {----Underflow Protected}
  575.                           IF (value<>0)
  576.                             THEN
  577.                               IF (ABS( LN(ABS(value))-LN(ABS(dummy)) )
  578.                                  <LN(Maxreal))
  579.                                 THEN value:=value/dummy
  580.                                 ELSE tfp_ernr:=11
  581.                         END
  582.                       ELSE tfp_ernr:=9;
  583.                   END;
  584.             END;
  585.     END;
  586.  
  587.   IF (tfp_ernr=0)
  588.     THEN Eval_subterm:=value
  589.     ELSE Eval_subterm:=0;
  590. END;
  591.  
  592. {---------------------------------------------------------}
  593. {  Real Expr  = Subterm + Subterm                         }
  594. {               Subterm - Subterm                         }
  595. {---------------------------------------------------------}
  596.  
  597. FUNCTION Eval_r_expr : REAL;
  598.  
  599. VAR
  600.   dummy,
  601.   dummy2,
  602.   value : REAL;
  603.  
  604. BEGIN
  605.   value:=Eval_subterm;
  606.  
  607.   WHILE (tfp_ernr=0) AND (Nextchar IN ['+','-']) DO
  608.     CASE Nextchar OF
  609.  
  610.       '+' : BEGIN
  611.               Skip;
  612.  
  613.               dummy:=Eval_subterm;
  614.  
  615.               IF (tfp_ernr=0)
  616.                 THEN
  617.                   BEGIN
  618.  
  619.                   {----Overflow Protected}
  620.                     IF (ABS( (value/10)+(dummy/10) )<(Maxreal/10))
  621.                       THEN value:=value+dummy
  622.                       ELSE tfp_ernr:=11;
  623.                   END;
  624.             END;
  625.  
  626.       '-' : BEGIN
  627.               Skip;
  628.               dummy2:=value;
  629.  
  630.               dummy:=Eval_subterm;
  631.  
  632.               IF (tfp_ernr=0)
  633.                 THEN
  634.                   BEGIN
  635.  
  636.                   {----Overflow Protected}
  637.                     IF (ABS( (value/10)-(dummy/10) )<(Maxreal/10))
  638.                       THEN value:=value-dummy
  639.                       ELSE tfp_ernr:=11;
  640.  
  641.                   {----Underflow Protected}
  642.                     IF (value=0) AND (dummy<>dummy2)
  643.                       THEN tfp_ernr:=11;
  644.                   END;
  645.  
  646.             END;
  647.     END;
  648.  
  649. {----At this point the current char must be
  650.         1. the EOLN marker or
  651.         2. a right bracket
  652.         3. start of a boolean operator }
  653.  
  654.   IF NOT (Nextchar IN [#00,')','>','<','=',','])
  655.     THEN tfp_ernr:=2;
  656.  
  657.   IF (tfp_ernr=0)
  658.     THEN Eval_r_expr:=value
  659.     ELSE Eval_r_expr:=0;
  660. END;
  661.  
  662. {---------------------------------------------------------}
  663. {  Boolean Expr  = R_Expr <  R_Expr                       }
  664. {                  R_Expr <= R_Expr                       }
  665. {                  R_Expr <> R_Expr                       }
  666. {                  R_Expr =  R_Expr                       }
  667. {                  R_Expr >= R_Expr                       }
  668. {                  R_Expr >  R_Expr                       }
  669. {---------------------------------------------------------}
  670.  
  671. FUNCTION Eval_b_expr : REAL;
  672.  
  673. VAR
  674.   value : REAL;
  675.  
  676. BEGIN
  677.   value:=Eval_r_expr;
  678.  
  679.   IF (tfp_ernr=0) AND (Nextchar IN ['<','>','='])
  680.     THEN
  681.       CASE Nextchar OF
  682.  
  683.         '<' : BEGIN
  684.                 Skip;
  685.                 IF (Nextchar IN ['>','='])
  686.                   THEN
  687.                     CASE Nextchar OF
  688.                       '>' : BEGIN
  689.                               Skip;
  690.                               IF (value<>Eval_r_expr)
  691.                                 THEN value:=tfp_true
  692.                                 ELSE value:=tfp_false;
  693.                             END;
  694.                       '=' : BEGIN
  695.                               Skip;
  696.                               IF (value<=Eval_r_expr)
  697.                                 THEN value:=tfp_true
  698.                                 ELSE value:=tfp_false;
  699.                             END;
  700.                     END
  701.                   ELSE
  702.                     BEGIN
  703.                       IF (value<Eval_r_expr)
  704.                         THEN value:=tfp_true
  705.                         ELSE value:=tfp_false;
  706.                     END;
  707.               END;
  708.  
  709.         '>' : BEGIN
  710.                 Skip;
  711.                 IF (Nextchar='=')
  712.                   THEN
  713.                     BEGIN
  714.                       Skip;
  715.                       IF (value>=Eval_r_expr)
  716.                         THEN value:=tfp_true
  717.                         ELSE value:=tfp_false;
  718.                     END
  719.                   ELSE
  720.                     BEGIN
  721.                       IF (value>Eval_r_expr)
  722.                         THEN value:=tfp_true
  723.                         ELSE value:=tfp_false;
  724.                     END;
  725.               END;
  726.         '=' : BEGIN
  727.                 Skip;
  728.                 IF (value=Eval_r_expr)
  729.                   THEN value:=tfp_true
  730.                   ELSE value:=tfp_false;
  731.               END;
  732.       END;
  733.  
  734.   IF (tfp_ernr=0)
  735.     THEN Eval_b_expr:=value
  736.     ELSE Eval_b_expr:=0.0;
  737. END;
  738.  
  739. {---------------------------------------------------------}
  740.  
  741. PROCEDURE Tfp_init(no : INTEGER);
  742.  
  743. BEGIN
  744.   IF (maxfie>0)
  745.     THEN FREEMEM(fiearr,maxfie*SIZEOF(fiearr^));
  746.  
  747.   GETMEM(fiearr,no*SIZEOF(fiearr^));
  748.  
  749.   maxfie:=no;
  750.   fiesiz:=0;
  751. END;
  752.  
  753. {---------------------------------------------------------}
  754.  
  755. FUNCTION Tfp_parse2real(s : string) : REAL;
  756.  
  757. VAR
  758.   i,h     : INTEGER;
  759.   value   : REAL;
  760.  
  761. BEGIN
  762.   tfp_ernr:=0;
  763.  
  764. {----Test for match on numbers of ( and ) }
  765.   h:=0;
  766.   FOR i:=1 TO LENGTH(s) DO
  767.     CASE s[i] OF
  768.       '(' : INC(h);
  769.       ')' : DEC(h);
  770.     END;
  771.  
  772.   IF (h=0)
  773.     THEN
  774.       BEGIN
  775.  
  776.       {----Continue init}
  777.         lp:=0;
  778.  
  779.       {----Add a CHR(0) as an EOLN marker}
  780.         line:=S+#00;
  781.         Skip;
  782.  
  783.       {----Try parsing if any characters left}
  784.         IF (Line[Lp]<>#00)
  785.           THEN value:=Eval_b_expr
  786.           ELSE tfp_ernr:=6;
  787.       END
  788.     ELSE tfp_ernr:=3;
  789.  
  790.   IF (tfp_ernr<>0)
  791.     THEN tfp_parse2real:=0.0
  792.     ELSE tfp_parse2real:=value;
  793. END;
  794.  
  795. {---------------------------------------------------------}
  796.  
  797. FUNCTION Tfp_parse2str(s : STRING;m,n : INTEGER) : STRING;
  798.  
  799. VAR
  800.   r   : REAL;
  801.   tmp : STRING;
  802.  
  803. BEGIN
  804.   r:=Tfp_parse2real(s);
  805.   IF (tfp_ernr=0)
  806.     THEN STR(r:m:n,tmp)
  807.     ELSE tmp:='';
  808.   Tfp_parse2str:=tmp;
  809. END;
  810.  
  811. {---------------------------------------------------------}
  812.  
  813. FUNCTION Tfp_errormsg;
  814.  
  815. BEGIN
  816.   CASE nr OF
  817.     0 : Tfp_errormsg:='Correct resultaat';                      {Error 0 }
  818.     1 : Tfp_errormsg:='Ongeldig getal formaat';                 {Error 1 }
  819.     2 : Tfp_errormsg:='Onbekende functie';                      {Error 2 }
  820.     3 : Tfp_errormsg:='Een haakje mist';                        {Error 3 }
  821.     4 : Tfp_errormsg:='Reele exponent geeft een complex getal'; {Error 4 }
  822.     5 : Tfp_errormsg:='TAN( (2n+1)*PI/2 ) bestaat niet';        {Error 5 }
  823.     6 : Tfp_errormsg:='Lege string';                            {Error 6 }
  824.     7 : Tfp_errormsg:='LN(x) of LOG(x) met x<=0 bestaat niet';  {Error 7 }
  825.     8 : Tfp_errormsg:='SQRT(x) met x<0 bestaat niet';           {Error 8 }
  826.     9 : Tfp_errormsg:='Deling door nul';                        {Error 9 }
  827.    10 : Tfp_errormsg:='Teveel functies & constanten';           {Error 10}
  828.    11 : Tfp_errormsg:='Tussenresultaat buiten getalbereik';     {Error 11}
  829.    12 : Tfp_errormsg:='Illegale tekens in functienaam';         {Error 12}
  830.    13 : Tfp_errormsg:='Geen (on)gelijkheid / te complex';       {Error 13}
  831.    14 : Tfp_errormsg:='Geen booleaanse expressie';              {Error 14}
  832.    15 : Tfp_errormsg:='Verkeerd aantal parameters';             {Error 15}
  833.   ELSE  Tfp_errormsg:='Onbekende fout';                         {Error xx}
  834.   END;
  835. END;
  836.  
  837. {---------------------------------------------------------}
  838.  
  839. PROCEDURE Tfp_addobj(a : pointer;n : tfp_fname;t : tfp_ftype);
  840.  
  841. VAR
  842.   i : INTEGER;
  843.  
  844. BEGIN
  845.   {$R-}
  846.   IF (fiesiz<maxfie)
  847.     THEN
  848.       BEGIN
  849.         INC(fiesiz);
  850.         WITH fiearr^[fiesiz] DO
  851.           BEGIN
  852.             faddr:=a;
  853.             fname:=n;
  854.             FOR i:=1 TO LENGTH(fname) DO
  855.               IF (UPCASE(fname[i]) IN ['0'..'9','_','A'..'Z'])
  856.                 THEN fname[i]:=UPCASE(fname[i])
  857.                 ELSE tfp_ernr:=12;
  858.               IF (LENGTH(fname)>0) AND
  859.                  NOT (fname[1] IN ['A'..'Z'])
  860.                 THEN tfp_ernr:=12;
  861.               ftype:=t;
  862.           END
  863.       END
  864.     ELSE tfp_ernr:=10
  865.   {$R+}
  866. END;
  867.  
  868. {---------------------------------------------------------}
  869. {----Internal Functions                                   }
  870. {---------------------------------------------------------}
  871.  
  872. {$F+}
  873. FUNCTION xABS(VAR r : REAL) : REAL;
  874.  
  875. BEGIN
  876.  xabs:=ABS(r);
  877. END;
  878.  
  879. FUNCTION xAND(VAR r;VAR n : INTEGER) : REAL;
  880.  
  881. TYPE
  882.   tmp   = ARRAY[0..0] OF REAL;
  883.  
  884. VAR
  885.   x     : REAL;
  886.   i     : INTEGER;
  887.  
  888. BEGIN
  889. {$R-}
  890.   FOR i:=0 TO n DO
  891.     IF (tmp(r)[i]<>tfp_false) AND (tmp(r)[i]<>tfp_true)
  892.       THEN
  893.         BEGIN
  894.           IF (tfp_ernr=0)
  895.             THEN tfp_ernr:=14;
  896.         END;
  897.    IF (tfp_ernr=0) AND (n>0)
  898.      THEN
  899.        BEGIN
  900.          x:=tfp_true*ORD(tmp(r)[0]=tfp_true);
  901.          FOR i:=1 TO n DO
  902.            x:=tfp_true*ORD((x=tfp_true) AND (tmp(r)[i]=tfp_true))
  903.        END
  904.      ELSE tfp_ernr:=15;
  905.   IF tfp_ernr=0
  906.     THEN xAND:=x
  907.     ELSE xAND:=0.0;
  908. {$R+}
  909. END;
  910.  
  911. FUNCTION xARCTAN(VAR r : REAL) : REAL;
  912.  
  913. BEGIN
  914.   xARCTAN:=ARCTAN(r);
  915. END;
  916.  
  917. FUNCTION xCOS(VAR r : REAL) : REAL;
  918.  
  919. BEGIN
  920.   xCOS:=COS(r);
  921. END;
  922.  
  923. FUNCTION xDEG(VAR r : REAL) : REAL;
  924.  
  925. BEGIN
  926.   xDEG:=(r/pi)*180;
  927. END;
  928.  
  929. FUNCTION xE : REAL;
  930.  
  931. BEGIN
  932.   xE:=EXP(1);
  933. END;
  934.  
  935. FUNCTION xEXP(VAR r : REAL) : REAL;
  936.  
  937. BEGIN
  938.   xEXP:=0;
  939.   IF (ABS(r)<LN(MAXREAL))
  940.     THEN xEXP:=EXP(r)
  941.     ELSE tfp_ernr:=11;
  942. END;
  943.  
  944. FUNCTION xFALSE : REAL;
  945.  
  946. BEGIN
  947.   xFALSE:=tfp_false;
  948. END;
  949.  
  950. FUNCTION xFRAC(VAR r : REAL) : REAL;
  951.  
  952. BEGIN
  953.   xFRAC:=FRAC(r);
  954. END;
  955.  
  956. FUNCTION xINT(VAR r : REAL) : REAL;
  957.  
  958. BEGIN
  959.   xINT:=INT(r);
  960. END;
  961.  
  962. FUNCTION xLN(VAR r : REAL) : REAL;
  963.  
  964. BEGIN
  965.   xLN:=0;
  966.   IF (r>0)
  967.     THEN xLN:=LN(r)
  968.     ELSE tfp_ernr:=7;
  969. END;
  970.  
  971. FUNCTION xLOG(VAR r : REAL) : REAL;
  972.  
  973. BEGIN
  974.   xLOG:=0;
  975.   IF (r>0)
  976.     THEN xLOG:=LN(r)/LN(10)
  977.     ELSE tfp_ernr:=7;
  978. END;
  979.  
  980. FUNCTION xMAX(VAR r;VAR n : INTEGER) : REAL;
  981.  
  982. TYPE
  983.   tmp   = ARRAY[0..0] OF REAL;
  984.  
  985. VAR
  986.   max   : REAL;
  987.   i     : INTEGER;
  988.  
  989. BEGIN
  990. {$R-}
  991.   max:=tmp(r)[0];
  992.   FOR i:=1 TO n DO
  993.     IF (tmp(r)[i]>max)
  994.       THEN max:=tmp(r)[i];
  995.   xMAX:=max;
  996. {$R+}
  997. END;
  998.  
  999. FUNCTION xMIN(VAR r;VAR n : INTEGER) : REAL;
  1000.  
  1001. TYPE
  1002.   tmp   = ARRAY[0..0] OF REAL;
  1003.  
  1004. VAR
  1005.   min   : REAL;
  1006.   i     : INTEGER;
  1007.  
  1008. BEGIN
  1009. {$R-}
  1010.   min:=tmp(r)[0];
  1011.   FOR i:=1 TO n DO
  1012.     IF (tmp(r)[i]<min)
  1013.       THEN min:=tmp(r)[i];
  1014.   xMIN:=min;
  1015. {$R+}
  1016. END;
  1017. FUNCTION xIOR(VAR r;VAR n : INTEGER) : REAL;
  1018.  
  1019. TYPE
  1020.   tmp   = ARRAY[0..0] OF REAL;
  1021.  
  1022. VAR
  1023.   x     : REAL;
  1024.   i     : INTEGER;
  1025.  
  1026. BEGIN
  1027. {$R-}
  1028.   FOR i:=0 TO n DO
  1029.     IF (tmp(r)[i]<>tfp_false) AND (tmp(r)[i]<>tfp_true)
  1030.       THEN
  1031.         BEGIN
  1032.           IF (tfp_ernr=0)
  1033.             THEN tfp_ernr:=14;
  1034.         END;
  1035.    IF (tfp_ernr=0) AND (n>0)
  1036.      THEN
  1037.        BEGIN
  1038.          x:=tfp_true*ORD(tmp(r)[0]=tfp_true);
  1039.          FOR i:=1 TO n DO
  1040.            x:=tfp_true*ORD((x=tfp_true) OR (tmp(r)[i]=tfp_true))
  1041.        END
  1042.      ELSE tfp_ernr:=15;
  1043.   IF tfp_ernr=0
  1044.     THEN xIOR:=x
  1045.     ELSE xIOR:=0.0;
  1046. {$R+}
  1047. END;
  1048.  
  1049. FUNCTION xPI : REAL;
  1050.  
  1051. BEGIN
  1052.   xPI:=PI;
  1053. END;
  1054.  
  1055. FUNCTION xRAD(VAR r : REAL) : REAL;
  1056.  
  1057. BEGIN
  1058.   xRAD:=(r/180)*pi;
  1059. END;
  1060.  
  1061. FUNCTION xROUND(VAR r : REAL) : REAL;
  1062.  
  1063. BEGIN
  1064.   xROUND:=ROUND(r);
  1065. END;
  1066.  
  1067. FUNCTION xSGN(VAR r : REAL) : REAL;
  1068.  
  1069. BEGIN
  1070.   IF (r>=0)
  1071.     THEN xSgn:=+1
  1072.     ELSE xSgn:=-1;
  1073. END;
  1074.  
  1075. FUNCTION xSIN(VAR r : REAL) : REAL;
  1076.  
  1077. BEGIN
  1078.   xSIN:=SIN(r);
  1079. END;
  1080.  
  1081. FUNCTION xSQR(VAR r : REAL) : REAL;
  1082.  
  1083. BEGIN
  1084.   xSQR:=0;
  1085.   IF ( ABS(2*LN(ABS(r))) )<LN(MAXREAL)
  1086.     THEN xSQR:=EXP( 2*LN(ABS(r)) )
  1087.     ELSE tfp_ernr:=11;
  1088. END;
  1089.  
  1090. FUNCTION xSQRT(VAR r : REAL) : REAL;
  1091.  
  1092. BEGIN
  1093.   xSQRT:=0;
  1094.   IF (r>=0)
  1095.     THEN xSQRT:=SQRT(r)
  1096.     ELSE tfp_ernr:=8;
  1097. END;
  1098.  
  1099. FUNCTION xTAN(VAR r : REAL) : REAL;
  1100.  
  1101. BEGIN
  1102.   xTAN:=0;
  1103.   IF (COS(r)=0)
  1104.     THEN tfp_ernr:=5
  1105.     ELSE xTAN:=SIN(r)/COS(r);
  1106. END;
  1107.  
  1108. FUNCTION xTRUE : REAL;
  1109.  
  1110. BEGIN
  1111.   xTRUE:=tfp_true;
  1112. END;
  1113.  
  1114. FUNCTION xXOR(VAR r1,r2 : REAL) : REAL;
  1115.  
  1116. BEGIN
  1117.  IF ((r1<>tfp_false) AND (r1<>tfp_true)) OR
  1118.     ((r2<>tfp_false) AND (r2<>tfp_true))
  1119.    THEN
  1120.      BEGIN
  1121.        IF (tfp_ernr=0)
  1122.          THEN tfp_ernr:=14;
  1123.      END
  1124.    ELSE xxor:=tfp_true*ORD((r1=tfp_true) XOR (r2=tfp_true));
  1125. END;
  1126.  
  1127. {$F-}
  1128.  
  1129. {---------------------------------------------------------}
  1130.  
  1131. PROCEDURE Tfp_addgonio;
  1132.  
  1133. BEGIN
  1134.   Tfp_addobj(@xARCTAN,'ARCTAN',tfp_1real);
  1135.   Tfp_addobj(@xCOS   ,'COS'   ,tfp_1real);
  1136.   Tfp_addobj(@xDEG   ,'DEG'   ,tfp_1real);
  1137.   Tfp_addobj(@xPI    ,'PI'    ,tfp_noparm);
  1138.   Tfp_addobj(@xRAD   ,'RAD'   ,tfp_1real);
  1139.   Tfp_addobj(@xSIN   ,'SIN'   ,tfp_1real);
  1140.   Tfp_addobj(@xTAN   ,'TAN'   ,tfp_1real);
  1141. END;
  1142.  
  1143. {---------------------------------------------------------}
  1144.  
  1145. PROCEDURE Tfp_addlogic;
  1146.  
  1147. BEGIN
  1148.   Tfp_addobj(@xAND   ,'AND'   ,tfp_nreal);
  1149.   Tfp_addobj(@xFALSE ,'FALSE' ,tfp_noparm);
  1150.   Tfp_addobj(@xIOR   ,'OR'    ,tfp_nreal);
  1151.   Tfp_addobj(@xTRUE  ,'TRUE'  ,tfp_noparm);
  1152.   Tfp_addobj(@xXOR   ,'XOR'   ,tfp_2real);
  1153. END;
  1154.  
  1155. {---------------------------------------------------------}
  1156.  
  1157. PROCEDURE Tfp_addmath;
  1158. BEGIN
  1159.   Tfp_addobj(@xABS   ,'ABS'   ,tfp_1real);
  1160.   Tfp_addobj(@xEXP   ,'EXP'   ,tfp_1real);
  1161.   Tfp_addobj(@xE     ,'E'     ,tfp_noparm);
  1162.   Tfp_addobj(@xLN    ,'LN'    ,tfp_1real);
  1163.   Tfp_addobj(@xLOG   ,'LOG'   ,tfp_1real);
  1164.   Tfp_addobj(@xSQR   ,'SQR'   ,tfp_1real);
  1165.   Tfp_addobj(@xSQRT  ,'SQRT'  ,tfp_1real);
  1166. END;
  1167.  
  1168. {---------------------------------------------------------}
  1169.  
  1170. PROCEDURE Tfp_addmisc;
  1171.  
  1172. BEGIN
  1173.   Tfp_addobj(@xFRAC  ,'FRAC'  ,tfp_1real);
  1174.   Tfp_addobj(@xINT   ,'INT'   ,tfp_1real);
  1175.   Tfp_addobj(@xMAX   ,'MAX'   ,tfp_nreal);
  1176.   Tfp_addobj(@xMIN   ,'MIN'   ,tfp_nreal);
  1177.   Tfp_addobj(@xROUND ,'ROUND' ,tfp_1real);
  1178.   Tfp_addobj(@xSGN   ,'SGN'   ,tfp_1real);
  1179. END;
  1180.  
  1181. {---------------------------------------------------------}
  1182.  
  1183. BEGIN
  1184. {----Module Init}
  1185.   tfp_ernr:=0;
  1186.   fiesiz:=0;
  1187.   maxfie:=0;
  1188.   fiearr:=NIL;
  1189. END.
  1190.  
  1191. -------------------------------------------------------------<cut here
  1192.  
  1193. Program Tfptst;
  1194.  
  1195. Uses
  1196.   crt,
  1197.   tfp_01;
  1198.  
  1199. {$F+}  {----Important don't forget it !!!}
  1200.  
  1201. Var
  1202.   r : real;
  1203.   i : Integer;
  1204.   t,
  1205.   s : String;
  1206.  
  1207. FUNCTION xFUZZY(VAR r : REAL) : REAL;
  1208.  
  1209. BEGIN
  1210.   IF (r>0.5)
  1211.     THEN xFUZZY:=0.5
  1212.     ELSE xFUZZY:=0.4;
  1213. END; {of xFUZZY}
  1214.  
  1215. FUNCTION xAGE : REAL;
  1216.  
  1217. VAR
  1218.   s    : string;
  1219.   e    : Integer;
  1220.   r    : Real;
  1221.  
  1222. BEGIN
  1223. {----default value in case of error}
  1224.   xAGE:=0;
  1225.  
  1226.   Write('Enter your age : '); Readln(s);
  1227.   Val(s,r,e);
  1228.  
  1229. {----Setting tfp_ernr will flag an error.
  1230.      Can be a user defined value}
  1231.  
  1232.   IF e<>0
  1233.     THEN tfp_ernr:=1
  1234.     ELSE xAGE:=r;
  1235. END; {of xAge}
  1236. {$F-}
  1237.  
  1238. Begin
  1239.   Tfp_init(40);
  1240.  
  1241. {----Add internal function packs}
  1242.   Tfp_addgonio;
  1243.   Tfp_addlogic;
  1244.   Tfp_addmath;
  1245.   Tfp_addmisc;
  1246.  
  1247. {----Add external functions}
  1248.   Tfp_addobj(@r     ,'TEMP'   ,tfp_realvar);
  1249.   Tfp_addobj(@i     ,'COUNTER',tfp_intvar);
  1250.   Tfp_addobj(@t     ,'USER'   ,tfp_realstr);
  1251.   Tfp_addobj(@xfuzzy,'FUZZY'  ,tfp_1real);
  1252.   Tfp_addobj(@xage  ,'AGE'    ,tfp_noparm);
  1253.  
  1254.   i:=1;
  1255.   t:='1.25';
  1256.   s:='2*COUNTER';
  1257.  
  1258.   Clrscr;
  1259.  
  1260. {----Example #1 using FOR index in expression}
  1261.   Writeln(tfp_errormsg(tfp_ernr));
  1262.   FOR i:=1 TO 3 DO
  1263.     Writeln(s,' := ',Tfp_parse2real(s):0:2);
  1264.   Writeln(tfp_errormsg(tfp_ernr));
  1265.  
  1266. {----Example #2 using a real from the main program}
  1267.   r:=15;
  1268.   s:='TEMP';
  1269.   Writeln(r:0:2,' := ',Tfp_parse2real(s):0:2);
  1270.  
  1271. {----Example #3 using a function that does something strange}
  1272.   s:='AGE-1';
  1273.   Writeln('Last years AGE := ',Tfp_parse2real(s):0:2);
  1274.  
  1275. {----Example #4 using a number in a string
  1276.      This version doesn't allow recusive formula's yet
  1277.      Have a version that does!}
  1278.   s:='USER';
  1279.   Writeln('USER := ',Tfp_parse2real(s):0:2);
  1280.  
  1281. {----All of the above + Internal function PI, &
  1282.      Boolean expressions should return 1 because it can't be 1
  1283.      Booleans are reals with values of 1.0 and 0.0}
  1284.   s:='(SIN(COUNTER+TEMP*FUZZY(AGE)*PI)<>1)=TRUE';
  1285.   Writeln('? := ',Tfp_parse2real(s):0:6);
  1286.  
  1287. {----Your example goes here, try a readln(s)}
  1288.  
  1289.   Writeln(tfp_errormsg(tfp_ernr));
  1290. End.
  1291.